home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
050
/
soundeff.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-05-14
|
5KB
|
315 lines
program sound_effects;
type
longstring = string[80];
var
x : integer;
thru : boolean;
ch : char;
procedure hilite(entry : longstring);
var
rest : string[79];
begin
rest := copy(entry,2,79);
textcolor(lightblue);
write(entry[1]);
textcolor(blue);
writeln(rest);
end;
procedure birdcall;
begin
repeat
sound(3500);
delay(random(49));
nosound;
delay(50);
sound(3000);
delay(random(49));
nosound;
delay(50);
sound(4000);
delay(random(49));
nosound;
delay(50);
until keypressed;
end;
procedure screech;
begin
repeat
x := 12000;
while (x>1400) do
begin
sound(x);
delay(6);
x := x - 100;
end;
until keypressed;
nosound;
end;
procedure clocktick;
begin
repeat
sound(12500);
delay(19);
nosound;
delay(1000);
until keypressed;
end;
procedure conveyor;
begin
repeat
for x := 37 to 100 do
begin
sound(x);
delay(6);
end;
until keypressed;
nosound;
end;
procedure doorbell;
var
a : integer;
begin
repeat
for x := 1 to 20 do
begin
a := 5700;
while (a < 16000) do
begin
sound(a);
delay(5);
nosound;
a := a + 1500;
end;
end;
delay(300);
until keypressed;
end;
procedure generator;
begin
for x := 37 to 300 do
begin
sound(x);
delay(9);
sound(2*x);
delay(9);
sound(3*x);
delay(9);
end;
repeat
sound(300);
delay(9);
sound(600);
delay(9);
sound(900);
delay(9);
until keypressed;
nosound;
end;
procedure torpedo;
begin
repeat
x := 4000;
while (x > 100) do
begin
sound(x);
delay(2);
sound(round(x/2+37));
delay(2);
sound(round(x/3+37));
delay(2);
x := x - 150;
end;
nosound;
delay(random(800));
until keypressed;
end;
procedure machine;
begin
repeat
x := 400;
while (x > 100) do
begin
sound(x);
delay(3);
sound(round(x/2+37));
delay(3);
sound(round(x/3+37));
delay(3);
x := x - 10;
end;
nosound;
until keypressed;
end;
procedure fazer;
begin
repeat
x := 300;
while (x < 1800) do
begin
sound(x);
delay(9);
x := x + 100;
end;
nosound;
until keypressed;
end;
procedure phone;
begin
repeat
for x := 1 to 30 do
begin
sound(523);
delay(40);
sound(659);
delay(40);
end;
nosound;
delay(1400);
until keypressed;
end;
procedure faucet;
begin
repeat
x := 800;
while (x < 1000) do
begin
sound(x);
delay(8);
x := x + 100;
end;
nosound;
delay(2000);
until keypressed;
end;
procedure computer;
begin
repeat
sound(random(2000));
delay(40);
until keypressed;
nosound;
end;
procedure explosion;
var
a : integer;
begin
repeat
for x := 1 to 5 do
begin
a := 300;
while (a < 1800) do
begin
sound(a);
delay(8);
a := a + 150;
end;
end;
nosound;
until keypressed;
end;
procedure saucer;
begin
repeat
x := 500;
while (x < 1500) do
begin
sound(x);
delay(41);
x := x + 200;
end;
nosound;
until keypressed;
end;
procedure control;
begin
while not thru do
begin
clrscr;
textcolor(blue);
write(' SOUND EFFECTS DEMONSTRATION ');
gotoxy(1,5);
hilite('A Computer Thinking');
hilite('Bird Call');
hilite('Conveyor Belt');
hilite('Doorbell');
hilite('Explosion');
hilite('Fazer Fire');
hilite('Generator Starting');
hilite('Hawk Screech');
hilite('Leaking Faucet');
hilite('Machine Noise');
hilite('Photon Torpedo');
hilite('Ringing Phone');
hilite('Saucer');
hilite('Ticking Clock');
writeln('* - End');
repeat until keypressed;
read(kbd,ch);
case upcase(ch) of
'B' : birdcall;
'H' : screech;
'T' : clocktick;
'C' : conveyor;
'D' : doorbell;
'G' : generator;
'P' : torpedo;
'M' : machine;
'F' : fazer;
'R' : phone;
'L' : faucet;
'A' : computer;
'E' : explosion;
'S' : saucer;
'*' : thru := true;
else writeln('Sorry, not implemented yet!');
end;
end;
end;
begin
thru := false;
control;
end. true;
else writeln('Sorry, not implemented yet!');
end;
end;
en